home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _fb23fe2641e5d5777ee28d745c70cc02 < prev    next >
Encoding:
Text File  |  2002-05-30  |  2.6 KB  |  111 lines
  1. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Optionmenu;
  5. require Tk::Menubutton;
  6. require Tk::Menu;
  7.  
  8. use vars qw($VERSION);
  9. $VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Optionmenu.pm#25 $
  10.  
  11. use base  qw(Tk::Derived Tk::Menubutton);
  12.  
  13. use strict;
  14.  
  15. Construct Tk::Widget 'Optionmenu';
  16.  
  17. sub Populate
  18. {
  19.  my ($w,$args) = @_;
  20.  $w->SUPER::Populate($args);
  21.  $args->{-indicatoron} = 1;
  22.  my $var = delete $args->{-textvariable};
  23.  unless (defined $var)
  24.   {
  25.    my $gen = undef;
  26.    $var = \$gen;
  27.   }
  28.  my $menu = $w->menu(-tearoff => 0);
  29.  $w->configure(-textvariable => $var);
  30.  
  31.  # Should we allow -menubackground etc. as in -label* of Frame ?
  32.  
  33.  $w->ConfigSpecs(-command => ['CALLBACK',undef,undef,undef],
  34.                  -options => ['METHOD', undef, undef, undef],
  35.          -variable=> ['PASSIVE', undef, undef, undef],
  36.          -font    => [['SELF',$menu], undef, undef, undef],
  37.  
  38.    -takefocus          => [ qw/SELF takefocus          Takefocus          1/ ],
  39.    -highlightthickness => [ qw/SELF highlightThickness HighlightThickness 1/ ],
  40.    -relief             => [ qw/SELF relief             Relief        raised/ ],
  41.  
  42.                 );
  43.  
  44.  # configure -variable and -command now so that when -options
  45.  # is set by main-line configure they are there to be set/called.
  46.  $w->configure(-variable => $var) if ($var = delete $args->{-variable});
  47.  $w->configure(-command  => $var) if ($var = delete $args->{-command});
  48. }
  49.  
  50. sub setOption
  51. {
  52.  my ($w, $label, $val) = @_;
  53.  $val = $label if @_ == 2;
  54.  my $var = $w->cget(-textvariable);
  55.  $$var = $label;
  56.  $var = $w->cget(-variable);
  57.  $$var = $val if $var;
  58.  $w->Callback(-command => $val);
  59. }
  60.  
  61. sub addOptions
  62. {
  63.  my $w = shift;
  64.  my $menu = $w->menu;
  65.  my $var = $w->cget(-textvariable);
  66.  my $old = $$var;
  67.  my $width = $w->cget('-width');
  68.  my %hash;
  69.  my $first;
  70.  while (@_)
  71.   {
  72.    my $val = shift;
  73.    my $label = $val;
  74.    if (ref $val)
  75.     {
  76.      ($label, $val) = @$val;
  77.     }
  78.    my $len = length($label);
  79.    $width = $len if (!defined($width) || $len > $width);
  80.    $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]);
  81.    $hash{$label} = $val;
  82.    $first = $label unless defined $first;
  83.   }
  84.  if (!defined($old) || !exists($hash{$old}))
  85.   {
  86.    $w->setOption($first, $hash{$first}) if defined $first;
  87.   }
  88.  $w->configure('-width' => $width);
  89. }
  90.  
  91. sub options
  92. {
  93.  my ($w,$opts) = @_;
  94.  if (@_ > 1)
  95.   {
  96.    $w->menu->delete(0,'end');
  97.    $w->addOptions(@$opts);
  98.   }
  99.  else
  100.   {
  101.    return $w->_cget('-options');
  102.   }
  103. }
  104.  
  105. 1;
  106.  
  107. __END__
  108.  
  109. =cut
  110.  
  111.